home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / plisp.em < prev    next >
Lisp/Scheme  |  1992-06-02  |  16KB  |  601 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56.  
  57.  
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109. (defmodule plisp (standard0 plural plisp-ll) ()
  110.  
  111.   (setq MP-Config 512)
  112.   (setq GC-TOP (mp-sb-ref))
  113.     
  114.  
  115.   (defclass xec ()
  116.     ((context
  117.       initarg context
  118.       reader  context)
  119.      (offset
  120.       initarg offset
  121.       reader  offset))
  122.     constructor (allocate-xec context offset)
  123.     predicate xecp)
  124.  
  125.   (defun make-xec (c o)
  126.     (become-strange (allocate-xec c o)))
  127.   
  128.   (defmethod generic-prin ((p xec) str)
  129.     (format str "#x(")
  130.     (mp-print (context p) (offset p) str)
  131.     (format str ")")
  132.     p)
  133.   
  134.   (defmethod generic-write ((p xec) str)
  135.     (format str "#x(")
  136.     (mp-print (context p) (offset p) str)
  137.     (format str ")")
  138.     p)
  139.  
  140.   (defclass mp-object ()
  141.     ((contexts 
  142.      initarg contexts
  143.      reader  contexts)
  144.     (offsets
  145.      initarg offsets
  146.      accessor offsets)
  147.     (index
  148.      initarg index
  149.      accessor index)
  150.     (shape
  151.      initarg shape
  152.      accessor shape))
  153.     predicate mp-object-p)
  154.  
  155.   
  156.   (defclass field (mp-object)
  157.     ()
  158.     constructor (allocate-field contexts offsets index shape)
  159.     predicate fieldp)
  160.  
  161.   (defun make-field (c o i s)
  162.     (become-strange (allocate-field c o i s)))
  163.   
  164.   (defmethod generic-prin ((f field) str)
  165.     (format str "#F(")
  166.     (mapcar (lambda (c o) (mp-print c o str)) (contexts f) (offsets f))
  167.     (format str ")")
  168.     f)
  169.   
  170.   (defmethod generic-write ((f field) str)
  171.     (format str "#F(")
  172.     (mapcar (lambda (c o) (mp-print c o str)) (contexts f) (offsets f))
  173.     (format str ")")
  174.     f)
  175.   
  176. ; if something is not a partial paralation, it is a global paralation,
  177. ; we can use the same one I think, as long as operations are independent.
  178. ; which I think they are though this will run into trouble with 
  179. ; recursive elwises.
  180.   
  181.   (setq MP-Context (mp-make-context MP-Config))
  182.   (setq MP-Offsets (cons (mp-make-plural MP-Context) ()))
  183.  
  184.   (setq MP-Nil (mp-bang MP-Context ()))
  185.  
  186.   (setq GC-Protect (list (make-xec MP-Context (car MP-Offsets))
  187.              (make-xec MP-Context MP-Nil)))
  188.  
  189.   (defun number-segment (ctxt ofst start size)
  190.     (format t "Renumber: start=~a size=~a\n" start size)
  191.     (labels ((recurse (i)
  192.              (if (< i (- size start)) (recurse (+ i 1)) ())
  193.                (mp-set ctxt ofst i (+ start i))))
  194.       (recurse 0)))
  195.   
  196.   (number-segment MP-Context (car MP-Offsets) 0 MP-Config)
  197.   
  198.   (defun number-segment (ctxt ofst start size)
  199.     (mp-bin-op ctxt (car MP-Offsets) 
  200.     (mp-bang ctxt (- start (cm-start ctxt)))     610))
  201.   
  202.   (setq VMP-Config MP-Config)
  203.   (setq PMP-Config (mp-bang MP-Context MP-Config))
  204.  
  205.   (setq GC-Protect (cons (make-xec MP-Context PMP-Config) GC-Protect))
  206.   
  207.   (defun enough-virtual-pes-p 
  208.     (required) (< required (+ VMP-Config MP-Config)))
  209.   
  210.   (defun more-processors (required)
  211.     (labels ((find-last (offsets)
  212.                (if (cdr offsets) (find-last (cdr offsets))
  213.              ((setter cdr) offsets (make-rest (car offsets)))))
  214.              (make-rest (offset)
  215.            (if (enough-virtual-pes-p required) ()
  216.              (let ((new-ofst (mp-bin-op MP-Context offset PMP-Config     610)))
  217.            (setq VMP-Config (+ VMP-Config MP-Config))
  218.          (setq GC-Protect (cons (make-xec MP-Context new-ofst)
  219.                     GC-Protect))
  220.            (cons new-ofst (make-rest new-ofst))))))
  221.       (find-last MP-Offsets)))
  222.   
  223.   (defun allocate-processors (required)
  224.     (if (not (enough-virtual-pes-p required)) (more-processors required) ())
  225.     (labels ((list-of-ctxts (allocated)
  226.                (if (>= (+ allocated MP-Config) required)
  227.              (list (mp-make-context (- required allocated)))
  228.              (cons MP-Context (list-of-ctxts (+ allocated MP-Config)))))
  229.              (list-of-ofsts (contexts offsets allocated)
  230.            (cond 
  231.             ((null contexts) ())
  232.             ((eq (car contexts) MP-Context)
  233.              (cons (car offsets) 
  234.                (list-of-ofsts (cdr contexts) (cdr offsets)
  235.                       (+ allocated MP-Config))))
  236.             (t (list (number-segment (car contexts)
  237.                          (mp-make-plural (car contexts))
  238.                          allocated required))))))
  239.       (let* ((contexts (list-of-ctxts 0))
  240.              (offsets  (list-of-ofsts contexts MP-Offsets 0)))
  241.       (make-field contexts offsets () ()))))
  242.  
  243.   (defcondition illegal-operation ())
  244.  
  245.   (defun make-paralation (size)
  246.     (if (< size 1) (error "Attempt to create empty paralation" illegal-operation)
  247.       (let ((new-field (allocate-processors size)))
  248.     ((setter index) new-field new-field)
  249.     new-field)))
  250.  
  251.   (defun field-ref (f i)
  252.     (let ((list-index (/ i MP-Config)))
  253.       (mp-ref (list-ref (contexts f) list-index)
  254.           (list-ref (offsets f) list-index) (remainder i MP-Config))))
  255.  
  256.   ((setter setter) field-ref (lambda (f i v)
  257.      (let ((list-index (/ i MP-Config)))
  258.        (mp-set (list-ref (contexts f) list-index)
  259.            (list-ref (offsets f) list-index) (remainder i MP-Config) v)
  260.        f)))
  261.  
  262.   (defun field-length (f)
  263.     (let ((ll (list-length (contexts  f))))
  264.       (+ (* (if (> ll 1) (- ll 1) 0) MP-Config) 
  265.      (mp-length (list-ref (contexts f) (- ll 1))))))
  266.  
  267. ; This implementation of paralation lisp is based on an existing 
  268. ; version of CM Lisp, in which most of the parallel operations are done
  269. ; in a global context called everywhere. I am going to attempt to use
  270. ; a similar system, but when performing a parallel operation we set
  271. ; the "global" context, THE-CONTEXT,  to be that of the current paralation
  272.   
  273. ; Primitives
  274. ; ==========
  275.  
  276.   (p-1-fn mp-un-op negate       620)
  277.   (p-1-fn mp-un-op abs     621)
  278.   (p-2-fn mp-eq eq ())
  279.   (p-2-fn mp-cons cons ())
  280.   (p-1-fn mp-car car ())
  281.   (p-1-fn mp-cdr cdr ())
  282.   (p-1-fn mp-make-vector make-vector())
  283.   (p-1-fn mp-vector-length vector-length ())
  284.   (p-2-fn mp-vector-ref vector-ref ())
  285.   (p-1-fn mp-test consp 2)
  286.   (p-1-fn mp-test intp 1)
  287.   (p-1-fn mp-test floatp 4)
  288.   (p-1-fn mp-test vectorp 3)
  289.   (p-2-fn mp-bin-op binary-plus     610)
  290.   (p-2-fn mp-bin-op +     610)
  291.   (p-2-fn mp-bin-op binary-difference 611)
  292.   (p-2-fn mp-bin-op - 611)
  293.   (p-2-fn mp-bin-op binary-times 613)
  294.   (p-2-fn mp-bin-op * 613)
  295.   (p-2-fn mp-bin-op binary-divide 612)
  296.   (p-2-fn mp-bin-op / 612)
  297.   (p-2-fn mp-rel-op binary-gt     651)
  298.   (p-2-fn mp-rel-op >     651)
  299.   (p-2-fn mp-rel-op binary-lt     650)
  300.   (p-2-fn mp-rel-op <     650)
  301.   (p-2-fn mp-bin-op remainder 614)
  302.   (p-0-fn mp-random c-rand ())
  303.   (p-2-fn mp-and and ())
  304.   (p-2-fn mp-or or ())
  305.   (p-1-fn mp-not not ())
  306.   
  307.   (p-2-fn mp-assign setq ())
  308.  
  309.   (p-3-set mp-vector-set vector-ref ())
  310.   (p-2-set mp-rplac-a car ())
  311.   (p-2-set mp-rplac-d cdr ())
  312.  
  313. ; There are a few lisp functions who work in parallel - this is a hack!
  314.  
  315.   ((setter table-ref) pfun-table 'progn (cons 'progn ()))
  316.  
  317.  
  318. ; Elwise
  319. ; ======
  320.  
  321. ; A few everywhere things are still useful
  322.  
  323.   (setq The-Context 'none)
  324.  
  325.   (defun Set-The-Context (v) (setq The-Context v))
  326.  
  327.   (defun rewire (form)
  328.     (cond 
  329.      ((consp form)
  330.       (cond
  331.        ((eq (car form) 'quote) (list 'mp-bang 'The-Context form))
  332.        ((eq (car form) (car function-name)) (cons (cadr function-name)
  333.                           (rewire (cdr form))))
  334.        ((eq (car form) 'if) (elwise-if (cadr form) (caddr form) (cadddr form)))
  335.        ((eq (car form) 'setter) (car (get-psetter (cadr form))))
  336.        ((eq (car form) 'cond) (cons 'let (cons '((cond-result 
  337.                         (mp-make-plural The-Context)))
  338.                     (cons '(mp-if The-Context (mp-bang The-Context t))
  339.                       (rewire-cond (cdr form))))))
  340.        ((eq (car form) 'lambda) (rewire-lambda (cdr form)))
  341.        ((eq (car form) 'let) (rewire-let (cdr form)))
  342.        (t (cons (if (car form) (rewire (car form)) MP-Nil)
  343.         (rewire (cdr form))))))
  344.      ((numberp form) (list 'mp-bang 'The-Context form))
  345.      ((memq form arg-list) form)
  346.      ((get-pfun form) (car (get-pfun form)))
  347.      ((null form) ())
  348.      (t (list 'mp-bang 'The-Context form))))
  349.  
  350.   (defun rewire-cond (form)
  351.     (if (null form) '((mp-fi The-Context) cond-result)
  352.       (cons
  353.        (list 'if (list 'mp-if 'The-Context (rewire (caar form)))
  354.          (list 'mp-assign 'The-Context 
  355.            'cond-result(rewire (cadar form))) ())
  356.        (cons '(mp-file The-Context)
  357.          (rewire-cond (cdr form))))))
  358.        
  359.   (defun rewire-let (form)
  360.     (let ((old-arg-list arg-list))
  361.       (setq arg-list (append (mapcar car (car form)) arg-list))
  362.       (let ((r-form (list 'let (mapcar (lambda (n-f-p)
  363.                      (cons (car n-f-p) 
  364.                            (rewire (cdr n-f-p))))
  365.                        (car form)) (cons 'progn (mapcar rewire 
  366.                                (cdr form))))))
  367.     (setq arg-list old-arg-list)
  368.     r-form)))
  369.  
  370.   (defun rewire-lambda (form)
  371.     (let ((old-arg-list arg-list))
  372.       (setq arg-list (append (car form) arg-list))
  373.       (let ((r-form (list 'lambda (car form) (rewire (cadr form)))))
  374.     (setq arg-list old-arg-list)
  375.     r-form)))
  376.  
  377.   (defun elwise-if (bool then else)
  378.     (let ((then (if then (rewire then) MP-Nil))
  379.       (else (if else (rewire else) MP-Nil)))
  380.       (list 'let '((if-result (mp-make-plural The-Context)))
  381.         (list 'if (list 'mp-if 'The-Context (rewire bool))
  382.           (list 'mp-assign 'The-Context 'if-result then) ())
  383.         (list 'if (list 'mp-else 'The-Context)
  384.           (list 'mp-assign 'The-Context 'if-result else) ())
  385.         '(mp-fi The-Context)
  386.         'if-result)))
  387.  
  388.   (defun eval-arg-list (arg-form)
  389.     (if (null arg-form) (list (list 'the-contexts 
  390.                     (list 'contexts (car arg-list)))
  391.                   (list 'the-index (list 'index (car arg-list)))
  392.                   (list 'the-shape (list 'shape (car arg-list)))
  393.                   '(the-offsets (mapcar mp-make-plural the-contexts))
  394.                   '(the-result (make-field the-contexts the-offsets the-index the-shape)))
  395.       (if (consp (car arg-form))
  396.         (progn 
  397.           (setq arg-list (cons (caar arg-form) arg-list))
  398.           (cons (car arg-form) (eval-arg-list (cdr arg-form))))
  399.         (progn 
  400.           (setq arg-list (cons (car arg-form) arg-list))
  401.           (eval-arg-list (cdr arg-form))))))
  402.  
  403.   (defun get-offsets (arg-list) 
  404.     (mapcar (lambda (f) (list `offsets f)) arg-list))
  405.  
  406.   (defmacro elwise (arg-form body)
  407.     (setq arg-list ())
  408.     (setq function-name '(none))
  409.     `(let* ,(eval-arg-list arg-form)
  410.        (mapcar (lambda ,(cons `the-context 
  411.                   (cons 'result-ofst arg-list))
  412.          (let ((tmp-pspace (mp-ps-ref)))
  413.            (mp-sb-set tmp-pspace)
  414.            (Set-The-Context the-context)
  415.            (mp-assign The-Context result-ofst
  416.                   ,(if body (rewire body) 
  417.                  (list 'mp-bang 'The-Context ())))
  418.            (mp-sb-set GC-TOP)
  419.            (mp-ps-set tmp-pspace)
  420.            result-ofst))
  421.            ,@(cons `the-contexts (cons `the-offsets 
  422.                        (get-offsets arg-list))))
  423.        the-result))
  424.        
  425.  
  426.  
  427.  
  428. ; to add primitives, particularly recursive primitives
  429.  
  430.   (defmacro depfun (name args body)
  431.     (setq arg-list args)
  432.     (setq function-name (list name (make-pfun-name name)))
  433.     (add-pfun name (cadr function-name) args)
  434.     `(progn (defun ,(cadr function-name) ,args ,(rewire body))
  435.         (export ,(cadr function-name))))
  436.  
  437. (defclass mapping (mp-object)
  438.   ()
  439.   constructor (make-mapping contexts offsets index shape)
  440.   predicate mappingp)
  441.  
  442. (defun allocate-mapping (c o i s)
  443.   (become-strange (make-mapping c o i s)))
  444.  
  445. ; It seems a non-trivial task to make this GC safe
  446.  
  447. (defun match (dest from)
  448.   (let ((result (allocate-mapping 
  449.          (contexts dest) (mapcar (lambda (d-c) 
  450.                        (mapcar (lambda (f-c) 
  451.                              (mp-make-plural d-c))
  452.                            (contexts from)))
  453.                      (contexts dest))
  454.          (index dest) (shape dest)))
  455.     (tmp-pspace (mp-ps-ref)))
  456.     (mp-sb-set tmp-pspace)
  457.     (labels ((seg-match (d-ctxt d-ofst r-ofsts ctxts ofsts)
  458.             (if (null ctxts) ()
  459.               (progn 
  460.                 (mp-assign d-ctxt (car r-ofsts) 
  461.                        (mp-match d-ctxt d-ofst 
  462.                          (car ctxts) (car ofsts)))
  463.                 (seg-match d-ctxt d-ofst (cdr r-ofsts)
  464.                         (cdr ctxts) (cdr ofsts))))))
  465.       (mapcar (lambda (c o r) 
  466.         (seg-match c o r (contexts from) (offsets from)))
  467.           (contexts dest) (offsets dest) (offsets result))
  468.       (mp-ps-set tmp-pspace)
  469.       (mp-sb-set GC-TOP)
  470.       result)))
  471.  
  472. ; Don't think this needs any protection the mpl protection (which I have yet to
  473. ; put in should be sufficient
  474.  
  475. (defun ll-move (data map)
  476.   (let ((initial (mapcar mp-make-plural (contexts map))))
  477.     (mapcar
  478.      (lambda (m-ctxt m-ofsts i-ofst)
  479.        (mapcar (lambda (d-ctxt d-ofst m-ofst)
  480.          (mp-move d-ctxt d-ofst m-ctxt m-ofst i-ofst))
  481.            (contexts data) (offsets data) m-ofsts))
  482.      (contexts map) (offsets map) initial)
  483.     initial))
  484.  
  485. (defmacro move (data map with default)
  486.   `(l-move ,data ,map ,(if (not (consp with)) (car (get-pfun with))
  487.              (progn
  488.                (setq arg-list (cadr with))
  489.                (list 'lambda arg-list (rewire (caddr with)))))
  490.       ,default))
  491.  
  492. (defun l-move (data map p-with default)
  493.     (labels  ((recurse (l-ofst cdrl-ofst r-ofst)
  494.         (if (mp-if The-Context cdrl-ofst)
  495.           (mp-assign The-Context r-ofst
  496.                  (p-with (mp-car The-Context l-ofst)
  497.                    (recurse cdrl-ofst 
  498.                         (mp-cdr The-Context cdrl-ofst)
  499.                         r-ofst))) ())
  500.         (mp-else The-Context)
  501.         (mp-assign The-Context r-ofst (mp-car The-Context l-ofst))
  502.         (mp-fi The-Context)
  503.         r-ofst))
  504.        (let ((result (make-field (contexts map) 
  505.                  (mapcar mp-make-plural (contexts map))
  506.                  (index map) (shape map))))
  507.       (mapcar (lambda (ctxt ofst r-ofst)
  508.             (let ((tmp-pspace (mp-ps-ref)))
  509.               (mp-sb-set tmp-pspace)
  510.               (Set-The-Context ctxt)
  511.               (mp-if ctxt ofst)
  512.               (recurse ofst (mp-cdr The-Context ofst) r-ofst)
  513.               (mp-else ctxt)
  514.               (mp-assign ctxt r-ofst (mp-bang ctxt default))
  515.               (mp-fi ctxt)
  516.               (mp-sb-set GC-TOP)
  517.               (mp-ps-set tmp-pspace)
  518.               r-ofst))
  519.           (contexts map) (ll-move data map) (offsets result))
  520.       result)))
  521.       
  522. (defun get (direction f default)
  523.   (let ((map (vector-ref (shape f) direction))
  524.     (result (make-field (contexts f) (mapcar mp-make-plural (contexts f))
  525.                 (index f) (shape f))))
  526.     (mapcar (lambda (c o r-o)
  527.           (let ((tmp-pspace (mp-ps-ref)))
  528.         (mp-sb-set tmp-pspace)
  529.         (mp-if c o) (mp-assign c r-o (mp-car c o))
  530.         (mp-else c) (mp-assign c r-o (mp-bang c default))
  531.         (mp-fi c)
  532.         (mp-sb-set GC-TOP)
  533.         (mp-ps-set tmp-pspace) r-o)) 
  534.           (contexts f) (ll-move f map) (offsets result))
  535.     result))
  536.  
  537. (defun enum-ll (bool-f)
  538.   (let ((result (elwise (bool-f) (if bool-f 1 0)))
  539.     (tmp-pspace (mp-ps-ref)))
  540.     (labels ((recurse (c-s o-s s)
  541.          (if (null c-s) ()
  542.            (progn
  543.              (mp-assign (car c-s) (car o-s) 
  544.                 (mp-bin-op (car c-s) 
  545.                        (mp-scan-op (car c-s) 
  546.                                (car o-s)     610)
  547.                        (mp-bang (car c-s) s)     610))
  548.              (recurse (cdr c-s) (cdr o-s)
  549.                   (mp-ref (car c-s) (car o-s)
  550.                       (- (mp-length (car c-s)) 1)))))))
  551.       (mp-sb-set tmp-pspace)
  552.       (recurse (contexts result) (offsets result) 0)
  553.       (mp-ps-set tmp-pspace)
  554.       (mp-sb-set GC-TOP)
  555.       result)))
  556.         
  557. (defun enum (bool-f)
  558.   (elwise (bool-f (new (enum-ll bool-f))) (if bool-f (- new 1) ())))
  559.  
  560. (defun choose (bool-f)
  561.   (let ((tmp (enum-ll bool-f)))
  562.     (match (make-paralation (field-ref tmp (- (field-length bool-f) 1)))
  563.        (elwise (tmp bool-f) (if bool-f (- tmp 1) ())))))
  564.  
  565. (defun count (bool-f)
  566.   (field-ref (enum-ll bool-f) (- (field-length bool-f) 1)))
  567.  
  568. (defun position (f o)
  569.   (let* ((tmp (elwise (f (i (index f))) (if (eq f o) i ())))
  570.      (tmp-pspace (mp-ps-ref))
  571.      (t-o (progn (mp-sb-set tmp-pspace) (mp-bang MP-Context 32768))))
  572.     (labels ((recurse (c-s o-s)
  573.           (cond
  574.            ((null c-s) ())
  575.            ((not (mp-if (car c-s) (car o-s)))
  576.         (progn (mp-fi (car c-s)) 
  577.                (recurse (cdr c-s) (cdr o-s))))
  578.            (t (progn
  579.             (mp-assign (car c-s) t-o (car o-s))
  580.             (mp-fi (car c-s))
  581.             (mp-ref (car c-s) (mp-scan-op (car c-s) t-o     661)
  582.                 (- (mp-length (car c-s)) 1)))))))
  583.       (let ((result (recurse (contexts f) (offsets tmp))))
  584.     (mp-sb-set GC-TOP)
  585.     (mp-ps-set tmp-pspace)
  586.     result))))
  587.  
  588. ; Vref
  589.  
  590. ; We want to create a map which will shift everything left in the global
  591. ; context, this can be used by all other contexts to the same effect
  592.  
  593.       
  594. (export depfun elwise match move make-paralation field-ref contexts offsets
  595.         index shape make-field Set-The-Context The-Context GC-TOP position
  596.     l-move choose enum count get fieldp field-length
  597.     allocate-xec rewire)
  598.  
  599. )
  600.  
  601.